{-# LANGUAGE FlexibleContexts           #-}
{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Text.LexemeParser
-- Copyright   :  (c) Stephen Tetley 2012
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- Parser for /properties/ files which are patterned after AFM
-- files.
--
--------------------------------------------------------------------------------

module Text.LexemeParser
  ( 
    LexemeParser
  , LexerSimple
  , spaceLexemeParser
  , arbCharLexemeParser

  , lexeme
  , whiteSpace
  , symbol
  , parens
  , braces
  , angles
  , brackets
  , semi 
  , comma
  , dot
  , colon
  , commaSep
  , semiSep
  , commaSep1
  , semiSep1

  , int

  ) where



import Text.Parsec

import Control.Applicative hiding ( many, (<|>) )
import Data.Char
import Data.Functor.Identity

newtype LexemeParser s u m = LexemeParser { 
    getLexemeParser :: ParsecT s u m () }

type LexerSimple = LexemeParser String () Identity


-- | Build a lexeme parser that handles /space/.
--
-- /Space/ is zero or more elements matching the @isSpace@
-- predicate from @Data.Char@.
--
-- Newline and tab are space.
-- 
spaceLexemeParser :: Stream s m Char => LexemeParser s u m
spaceLexemeParser = LexemeParser go 
  where
    go = () <$ many space



-- | Build a lexeme parser that handles arbitrary /space/.
--
-- /space/ is parametric, for instance this can manufacture a 
-- lexeme parser that consumes space and tab chars but not 
-- newline.
--
arbCharLexemeParser :: Stream s m Char => [Char] -> LexemeParser s u m 
arbCharLexemeParser cs = LexemeParser go 
  where
    go = skipMany (oneOf cs)

--------------------------------------------------------------------------------


lexeme :: LexemeParser s u m -> ParsecT s u m a -> ParsecT s u m a 
lexeme trail p = p <* getLexemeParser trail


whiteSpace :: LexemeParser s u m -> ParsecT s u m ()
whiteSpace = getLexemeParser

symbol :: Stream s m Char => LexemeParser s u m -> String -> ParsecT s u m String
symbol lx s = lexeme lx (string s)

parens :: Stream s m Char 
       => LexemeParser s u m -> ParsecT s u m a -> ParsecT s u m a 
parens lx p = between (symbol lx "(") (symbol lx ")") p

braces :: Stream s m Char 
       => LexemeParser s u m -> ParsecT s u m a -> ParsecT s u m a 
braces lx p = between (symbol lx "{") (symbol lx "}") p

angles :: Stream s m Char 
       => LexemeParser s u m -> ParsecT s u m a -> ParsecT s u m a 
angles lx p = between (symbol lx "<") (symbol lx ">") p

brackets :: Stream s m Char 
         => LexemeParser s u m -> ParsecT s u m a -> ParsecT s u m a 
brackets lx p = between (symbol lx "[") (symbol lx "]") p


semi        :: Stream s m Char => LexemeParser s u m -> ParsecT s u m String
semi lx     = symbol lx ";"

comma       :: Stream s m Char => LexemeParser s u m -> ParsecT s u m String
comma lx    = symbol lx ","

dot         :: Stream s m Char => LexemeParser s u m -> ParsecT s u m String
dot lx      = symbol lx "."

colon       :: Stream s m Char => LexemeParser s u m -> ParsecT s u m String
colon lx    = symbol lx ":"


commaSep    :: Stream s m Char 
            => LexemeParser s u m -> ParsecT s u m a -> ParsecT s u m [a]
commaSep lx p = sepBy p (comma lx)

semiSep     :: Stream s m Char 
            => LexemeParser s u m -> ParsecT s u m a -> ParsecT s u m [a]
semiSep lx p = sepBy p (semi lx)


commaSep1       :: Stream s m Char 
                => LexemeParser s u m -> ParsecT s u m a -> ParsecT s u m [a]
commaSep1 lx p  = sepBy1 p (comma lx)

semiSep1        :: Stream s m Char 
                => LexemeParser s u m -> ParsecT s u m a -> ParsecT s u m [a]
semiSep1 lx p   = sepBy1 p (semi lx)


--------------------------------------------------------------------------------
-- Numbers
--------------------------------------------------------------------------------

sign            :: (Num a, Stream s m Char) => ParsecT s u m (a -> a)
sign            =  (char '-' >> return negate)
               <|> (char '+' >> return id)
               <|> return id


intDigits       :: Stream s m Char => ParsecT s u m Int
intDigits       = go 0 <$> many1 digit
  where
    go acc []     = acc
    go acc (n:ns) = go (acc * 10 + digitToInt n) ns


-- | @int@ differs from Parsec\'s @int@ - here it is for base 10 
-- numbers.
--
int             :: Stream s m Char => LexemeParser s u m -> ParsecT s u m Int
int lx          = lexeme lx ( ($) <$> sign <*> intDigits)